home *** CD-ROM | disk | FTP | other *** search
/ IRIS Performer 2.2 Friends Demo / SGI IRIS Performer 2.2 Friends Demo.iso / friends / openworlds / tix / Control.tcl < prev    next >
Text File  |  1997-11-22  |  11KB  |  427 lines
  1. # TixControl Widget
  2. #    Probably a bad name, but it started with this name so let's keep
  3. #    it. It is called the "SpinBox" in other toolkits.
  4. #
  5.  
  6. tixWidgetClass tixControl {
  7.     -classname  TixControl
  8.     -superclass tixLabelWidget
  9.     -method {
  10.     incr decr invoke update
  11.     }
  12.     -flag {
  13.     -allowempty -autorepeat -command -decrcmd -disablecallback
  14.     -disabledforeground -incrcmd -initwait -integer -llimit
  15.     -repeatrate -max -min -selectmode -step -state -validatecmd
  16.     -value -variable -ulimit
  17.     }
  18.     -forcecall {
  19.     -variable -state
  20.     }
  21.     -configspec {
  22.     {-allowempty allowEmpty AllowEmpty false}
  23.     {-autorepeat autoRepeat AutoRepeat true}
  24.     {-command command Command {}}
  25.     {-decrcmd decrCmd DecrCmd {}}
  26.     {-disablecallback disableCallback DisableCallback false}
  27.     {-disabledforeground disabledForeground DisabledForeground #303030}
  28.     {-incrcmd incrCmd IncrCmd {}}
  29.     {-initwait initWait InitWait 500}
  30.     {-integer integer Integer false}
  31.     {-max max Max {}}
  32.     {-min min Min {}}
  33.     {-repeatrate repeatRate RepeatRate 50}
  34.     {-step step Step 1}
  35.     {-state state State normal}
  36.     {-selectmode selectMode SelectMode normal}
  37.     {-validatecmd validateCmd ValidateCmd {}}
  38.     {-value value Value 0}
  39.     {-variable variable Variable {}}
  40.     }
  41.     -alias {
  42.     {-llimit -min}
  43.     {-ulimit -max}
  44.     }
  45.     -default {
  46.     {.borderWidth             0}
  47.     {*entry.relief            sunken}
  48.     {*entry.width            5}
  49.     {*label.anchor            e}
  50.     {*label.borderWidth        0}
  51.     {*Label.font                   -Adobe-Helvetica-Bold-R-Normal--*-120-*}
  52.     {*Button.anchor            c}
  53.     {*Button.borderWidth        2}
  54.     {*Button.highlightThickness    1}
  55.     {*Button.takeFocus        0}
  56.     {*Entry.background        #c3c3c3}
  57.     }
  58. }
  59.  
  60. proc tixControl::InitWidgetRec {w} {
  61.     upvar #0 $w data
  62.  
  63.     tixChainMethod $w InitWidgetRec
  64.  
  65.     set data(varInited)      0
  66.     set data(serial)    0
  67. }
  68.  
  69. proc tixControl::ConstructFramedWidget {w frame} {
  70.     upvar #0 $w data
  71.  
  72.     tixChainMethod $w ConstructFramedWidget $frame
  73.  
  74.     set data(w:entry)  [entry $frame.entry]
  75.  
  76.     set data(w:incr) [button $frame.incr -bitmap [tix getbitmap incr] \
  77.     -takefocus 0]
  78.     set data(w:decr) [button $frame.decr -bitmap [tix getbitmap decr] \
  79.     -takefocus 0]
  80.  
  81. #    tixForm $data(w:entry) -left 0 -top 0 -bottom -1 -right $data(w:decr) 
  82. #    tixForm $data(w:incr) -right -1 -top 0 -bottom %50
  83. #    tixForm $data(w:decr) -right -1 -top $data(w:incr) -bottom -1
  84.  
  85.     pack $data(w:entry) -side left   -expand yes -fill both
  86.     pack $data(w:decr)  -side bottom -fill both -expand yes
  87.     pack $data(w:incr)  -side top    -fill both -expand yes
  88.  
  89.     $data(w:entry) delete 0 end
  90.     $data(w:entry) insert 0 $data(-value)
  91.  
  92.     # This value is used to configure the disable/normal fg of the ebtry
  93.     set data(entryfg) [lindex [$data(w:entry) config -fg] 4]
  94.     set data(labelfg) [lindex [$data(w:label) config -fg] 4]
  95. }
  96.  
  97. proc tixControl::SetBindings {w} {
  98.     upvar #0 $w data
  99.  
  100.     tixChainMethod $w SetBindings
  101.  
  102.     bind $data(w:incr) <ButtonPress-1> "tixControl::StartRepeat $w  1"
  103.     bind $data(w:decr) <ButtonPress-1> "tixControl::StartRepeat $w -1"
  104.  
  105.     # These bindings will stop the button autorepeat when the 
  106.     # mouse button is up
  107.     foreach btn "$data(w:incr) $data(w:decr)" {
  108.     bind $btn <ButtonRelease-1> "tixControl::StopRepeat $w"
  109.     }
  110.  
  111.     tixSetMegaWidget $data(w:entry) $w
  112.  
  113.     # If user press <return>, verify the value and call the -command
  114.     #
  115.     tixAddBindTag $data(w:entry) TixControl:Entry 
  116. }
  117.  
  118. bind TixControl:Entry <Return> {
  119.     tixControl::invoke [tixGetMegaWidget %W]
  120. }
  121. bind TixControl:Entry <Escape> {
  122.     tixControl::Escape [tixGetMegaWidget %W]
  123. }
  124. bind TixControl:Entry <Up> {
  125.     [tixGetMegaWidget %W] incr
  126. }
  127. bind TixControl:Entry <Down> {
  128.     [tixGetMegaWidget %W] decr
  129. }
  130. bind TixControl:Entry <FocusOut> {
  131.     if {"%d" == "NotifyNonlinear" || "%d" == "NotifyNonlinearVirtual"} {
  132.     tixControl::Tab [tixGetMegaWidget %W] %d
  133.     }
  134. }
  135. bind TixControl:Entry <Any-KeyPress> {
  136.     tixControl::KeyPress [tixGetMegaWidget %W]
  137. }
  138. bind TixControl:Entry <Any-Tab> {
  139.     # This has a higher priority than the <Any-KeyPress>  binding
  140.     # --> so that data(edited) is not set
  141. }
  142.  
  143. #----------------------------------------------------------------------
  144. #                           CONFIG OPTIONS
  145. #----------------------------------------------------------------------
  146. proc tixControl::config-state {w arg} {
  147.     upvar #0 $w data
  148.  
  149.     if {$arg == "normal"} {
  150.     $data(w:incr)  config -state $arg
  151.     $data(w:decr)  config -state $arg
  152.     $data(w:label) config -fg $data(labelfg)
  153.     $data(w:entry) config -state $arg -fg $data(entryfg)
  154.     } else {
  155.     $data(w:incr)  config -state $arg
  156.     $data(w:decr)  config -state $arg
  157.     $data(w:label) config -fg $data(-disabledforeground)
  158.     $data(w:entry) config -state $arg -fg $data(-disabledforeground)
  159.     }
  160. }
  161.  
  162. proc tixControl::config-value {w value} {
  163.     upvar #0 $w data
  164.  
  165.     tixControl::SetValue $w $value 0 1
  166.  
  167.     # This will tell the Intrinsics: "Please use this value"
  168.     # because "value" might be altered by SetValues
  169.     #
  170.     return $data(-value)
  171. }
  172.  
  173. proc tixControl::config-variable {w arg} {
  174.     upvar #0 $w data
  175.  
  176.     if [tixVariable:ConfigVariable $w $arg] {
  177.        # The value of data(-value) is changed if tixVariable:ConfigVariable 
  178.        # returns true
  179.        tixControl::SetValue $w $data(-value) 1 1
  180.     }
  181.     catch {
  182.     unset data(varInited)
  183.     }
  184.     set data(-variable) $arg
  185. }
  186.  
  187. #----------------------------------------------------------------------
  188. #                         User Commands
  189. #----------------------------------------------------------------------
  190. proc tixControl::incr {w {by 1}} {
  191.     upvar #0 $w data
  192.     if {[catch {$data(w:entry) index sel.first}] == 0} {
  193.     $data(w:entry) select from end
  194.     $data(w:entry) select to   end
  195.     }
  196.  
  197.     tixControl::SetValue $w [$data(w:entry) get] 0 1
  198.     tixControl::AdjustValue $w $by
  199. }
  200.  
  201. proc tixControl::decr {w {by 1}} {
  202.     upvar #0 $w data
  203.     if {[catch {$data(w:entry) index sel.first}] == 0} {
  204.     $data(w:entry) select from end
  205.     $data(w:entry) select to   end
  206.     }
  207.  
  208.     tixControl::SetValue $w [$data(w:entry) get] 0 1
  209.     tixControl::AdjustValue $w [expr 0 - $by]
  210. }
  211.  
  212. proc tixControl::invoke {w} {
  213.     upvar #0 $w data
  214.  
  215.     catch {
  216.     unset data(edited)
  217.     }
  218.  
  219.     if {[catch {$data(w:entry) index sel.first}] == 0} {
  220.     # THIS ENTRY OWNS SELECTION --> TURN IT OFF
  221.     #
  222.     $data(w:entry) select from end
  223.     $data(w:entry) select to   end
  224.     }
  225.  
  226.     tixControl::SetValue $w [$data(w:entry) get] 0 0
  227. }
  228.  
  229. proc tixControl::update {w} {
  230.     upvar #0 $w data
  231.  
  232.     if [info exists data(edited)] {
  233.     tixControl::invoke $w
  234.     }
  235. }
  236.  
  237. #----------------------------------------------------------------------
  238. #                       Internal Commands
  239. #----------------------------------------------------------------------
  240.  
  241. # Change the value by a multiple of the data(-step)
  242. #
  243. proc tixControl::AdjustValue {w amount} {
  244.     upvar #0 $w data
  245.  
  246.     if {$amount == 1 && $data(-incrcmd) != {}} {
  247.     set newValue [eval $data(-incrcmd) [list $data(-value)]]
  248.     } elseif {$amount == -1 && $data(-decrcmd) != {}} {
  249.     set newValue [eval $data(-decrcmd) [list $data(-value)]]
  250.     } else {
  251.     set newValue [expr $data(-value) + $amount * $data(-step)]
  252.     }
  253.  
  254.     if {$data(-state) != "disabled"} {
  255.     tixControl::SetValue $w $newValue 0 1
  256.     }
  257. }
  258.  
  259. proc tixControl::SetValue {w newvalue noUpdate forced} {
  260.     upvar #0 $w data
  261.  
  262.     set oldvalue $data(-value)
  263.     set oldCursor [$data(w:entry) index insert]
  264.     set changed 0
  265.  
  266.     if {$data(-validatecmd) != {}} {
  267.     # Call the user supplied validation command
  268.     #
  269.     set data(-value) [eval $data(-validatecmd) [list $newvalue]]
  270.     } else {
  271.     # Here we only allow int or floating numbers
  272.     #
  273.     # If the new value is not a valid number, the old value will be
  274.     # kept due to the "catch" statements
  275.     #
  276.     if {$newvalue == {}} {
  277.         if {![tixGetBoolean -nocomplain $data(-allowempty)]} {
  278.         set newvalue 0
  279.         set changed 1
  280.         } else {
  281.         set data(-value) {}
  282.         }
  283.     }
  284.  
  285.     if {$newvalue != {}} {
  286.         # Change this to a valid decimal string (trim leading 0)
  287.         #
  288.         regsub {^[0]*} $newvalue {} newvalue
  289.         if {$newvalue == {}} {
  290.         set newvalue 0
  291.         }
  292.  
  293.         if [tixGetBoolean -nocomplain $data(-integer)] {
  294.         set data(-value) [tixGetInt -nocomplain $newvalue]
  295.         } else {
  296.         if [catch {set data(-value) [format "%d" $newvalue]}] {
  297.             if [catch {set data(-value) [format "%f" $newvalue]}] {
  298.             set data(-value) $oldvalue
  299.             }
  300.         }
  301.         }
  302.         
  303.         # Now perform boundary checking
  304.         #
  305.         if {$data(-max) != {} && $data(-value) > $data(-max)} {
  306.         set data(-value) $data(-max)
  307.         }
  308.         if {$data(-min) != {} && $data(-value) < $data(-min)} {
  309.         set data(-value) $data(-min)
  310.         }
  311.     }
  312.     }
  313.  
  314.     if {! $noUpdate} {
  315.     tixVariable:UpdateVariable $w
  316.     }
  317.  
  318.     if {$forced || $newvalue != $data(-value) || $changed} {
  319.     $data(w:entry) delete 0 end
  320.     $data(w:entry) insert 0 $data(-value)
  321.     $data(w:entry) icursor $oldCursor
  322.     }
  323.  
  324.     if {![tixGetBoolean $data(-disablecallback)] && $data(-command) != {}} {
  325.     if {![info exists data(varInited)]} {
  326.         eval $data(-command) [list $data(-value)]
  327.     }
  328.     }
  329. }
  330.  
  331. #----------------------------------------------------------------------
  332. # The three functions StartRepeat, Repeat and StopRepeat make use of the
  333. # data(serial) variable to discard spurious repeats: If a button is clicked
  334. # repeatedly but is not hold down, the serial counter will increase
  335. # successively and all "after" time event handlers will be discarded
  336. #----------------------------------------------------------------------
  337. proc tixControl::StartRepeat {w amount} {
  338.     if {![winfo exists $w]} {
  339.     return
  340.     }
  341.  
  342.     upvar #0 $w data
  343.  
  344.     if {[catch {$data(w:entry) index sel.first}] == 0} {
  345.     $data(w:entry) select from end
  346.     $data(w:entry) select to   end
  347.     }
  348.  
  349.     if [info exists data(edited)] {
  350.     unset data(edited)
  351.     tixControl::SetValue $w [$data(w:entry) get] 0 1
  352.     }
  353.  
  354.     incr data(serial)
  355.  
  356.     tixControl::AdjustValue $w $amount
  357.  
  358.     if {$data(-autorepeat)} {
  359.     after $data(-initwait) tixControl::Repeat $w $amount $data(serial)
  360.     }
  361.  
  362.     focus $data(w:entry)
  363. }
  364.  
  365. proc tixControl::Repeat {w amount serial} {
  366.     if {![winfo exists $w]} {
  367.     return
  368.     }
  369.     upvar #0 $w data
  370.  
  371.     if {$serial == $data(serial)} {
  372.     tixControl::AdjustValue $w $amount
  373.  
  374.     if {$data(-autorepeat)} {
  375.        after $data(-repeatrate) tixControl::Repeat $w $amount $data(serial)
  376.     }
  377.     }
  378. }
  379.  
  380. proc tixControl::StopRepeat {w} {
  381.     upvar #0 $w data
  382.  
  383.     incr data(serial)
  384. }
  385.  
  386. proc tixControl::Destructor {w} {
  387.  
  388.     tixVariable:DeleteVariable $w
  389.  
  390.     # Chain this to the superclass
  391.     #
  392.     tixChainMethod $w Destructor
  393. }
  394.  
  395. # ToDo: maybe should return -code break if the value is not good ...
  396. #
  397. proc tixControl::Tab {w detail} {
  398.     upvar #0 $w data
  399.  
  400.     if {![info exists data(edited)]} {
  401.     return
  402.     } else {
  403.     unset data(edited)
  404.     }
  405.  
  406.     tixControl::invoke $w
  407. }
  408.  
  409. proc tixControl::Escape {w} {
  410.     upvar #0 $w data
  411.  
  412.     $data(w:entry) delete 0 end
  413.     $data(w:entry) insert 0 $data(-value)
  414. }
  415.  
  416. proc tixControl::KeyPress {w} {
  417.     upvar #0 $w data
  418.  
  419.     if {$data(-selectmode) == "normal"} {
  420.     set data(edited) 0
  421.     return
  422.     } else {
  423.     # == "immediate"
  424.     after 1 tixControl::invoke $w
  425.     }
  426. }
  427.